home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM A / PD-ROM A.iso / Programming / Programming Languages / XLISP 2.0 / XLISP Tools / Utility (UL) / GRIND.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1988-04-07  |  2.7 KB  |  95 lines  |  [TEXT/ttxt]
  1. ;; Larry Mulcahy 1988
  2. ;; grind
  3.  
  4. (provide 'grind)
  5. (require 'array)
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ; grind
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (defmacro grind (s) `(pprint (expr-to-make ',s)))
  12.  
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; expr-to-make 
  15. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16.  
  17. (defun expr-to-make (symbol)
  18.   (let
  19.     ((result nil)
  20.     )
  21.     (if (symbol-plist symbol)
  22.       (push (expr-to-make-plist symbol) result))
  23.     (if (boundp symbol)
  24.       (push (expr-to-set-value symbol) result))
  25.     (if (fboundp symbol)
  26.       (push (expr-to-make-function symbol) result))
  27.     (if (> (length result) 1)
  28.       `(progn ,@result)
  29.       (car result))
  30.   ))
  31.  
  32. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  33. ; expr-to-make-function 
  34. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  35.  
  36. (defun expr-to-make-function (symbol)
  37.   (let ((f (symbol-function symbol)))
  38.     (if (not (equal (type-of f) 'subr))
  39.         (let*
  40.           ((l (get-lambda-expression f))
  41.            (function-type (car l))    ; LAMBDA or MACRO
  42.            (defining-word
  43.              (case function-type
  44.                (lambda 'defun)
  45.                (macro 'defmacro)))
  46.            (params (cadr l))
  47.            (body (cddr l))
  48.           )
  49.         `(,defining-word ,symbol ,params ,@body)))))
  50.  
  51.  
  52. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  53. ; expr-to-set-value 
  54. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  55.  
  56. (defun expr-to-set-value (symbol)
  57.   (let
  58.     ((v (symbol-value symbol))
  59.     )
  60.     `(setq ,symbol ,(expr-to-make-value v))
  61.   ))
  62.  
  63. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  64. ; expr-to-make-value 
  65. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  66.  
  67. (defun expr-to-make-value (v)
  68.   (case (type-of v)
  69.     (cons `(list ,@(mapcar #'expr-to-make-value v)))
  70.     (symbol
  71.       (if (symbol-plist v)
  72.         (let ((plist-maker (expr-to-make-plist v)))
  73.           `(progn ,plist-maker ',v))
  74.         `',v))
  75.     ((fixnum flonum string) v)
  76.     (closure (get-lambda-expression v))
  77.     (array `(vector ,@(mapcar #'expr-to-make-value (vector-to-list v))))
  78.   ))
  79.  
  80. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  81. ; expr-to-make-plist 
  82. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  83.  
  84. (defun expr-to-make-plist (symbol)
  85.   (let*
  86.     ((p (plist-names (symbol-plist symbol)))
  87.      (putprop-exprs
  88.       (mapcar
  89.         #'(lambda (prop) `(putprop ',symbol ',(get symbol prop) ',prop))
  90.         p)))
  91.     (if (> (length putprop-exprs) 1)
  92.       `(progn ,@putprop-exprs)
  93.       (car putprop-exprs))))
  94.  
  95.